home *** CD-ROM | disk | FTP | other *** search
/ EnigmA Amiga Run 1997 July / EnigmA AMIGA RUN 20 (1997)(G.R. Edizioni)(IT)[!][issue 1997-07 & 08][EAR-CD IV].iso / earcd / game / text / lists.lha / listsdir / zlisp-funs.inf < prev    next >
Text File  |  1996-12-06  |  14KB  |  644 lines
  1.  
  2. Constant MAX_LIST_ARGS 4;
  3.  
  4. Array list_args --> MAX_LIST_ARGS;
  5. Global num_list_args;
  6.  
  7. Array aname_quote string "quote";
  8. Array aname_internal_dict string "internal-dict";
  9. Array aname_error string "error";
  10. Array aname_nil string "nil";
  11. Array aname_t string "t";
  12. Array aname_s string "s";
  13. Array aname_s2 string "s2";
  14. Array aname_s3 string "s3";
  15. Array aname_not string "not";
  16. Array aname_eqvp string "eqv?";
  17. Array aname_equalp string "equal?";
  18. Array aname_nullp string "null?";
  19. Array aname_listp string "list?";
  20. Array aname_eqnum string "=";
  21. Array aname_gt string ">";
  22. Array aname_lt string "<";
  23. Array aname_gte string ">=";
  24. Array aname_lte string "<=";
  25. Array aname_plus string "+";
  26. Array aname_minus string "-";
  27. Array aname_car string "car";
  28. Array aname_cdr string "cdr";
  29. Array aname_cons string "cons";
  30. Array aname_length string "length";
  31. Array aname_cond string "cond";
  32. Array aname_lambda string "lambda";
  33. Array aname_define string "define";
  34. Array aname_let string "let";
  35. Array aname_letstar string "let*";
  36. Array aname_letrec string "letrec";
  37. Array aname_list string "list";
  38. Array aname_eval string "eval";
  39.  
  40. Global atom_quote;
  41. Global atom_t;
  42. Global atom_s;
  43. Global atom_s2;
  44. Global atom_s3;
  45.  
  46. ! --- startup code
  47.  
  48. [ make_initial_stuff
  49.     dict atm ix;
  50.     
  51.     dict = 0;
  52.     top_level_env = 0;
  53.     
  54.     atm = string_to_atom(aname_quote);
  55.     if (atm == tok_Error)
  56.         return tok_Error;
  57.     atom_quote = atm;
  58.     dict = alloc_cons(atm, dict);
  59.  
  60.     atm = string_to_atom(aname_s);
  61.     if (atm == tok_Error)
  62.         return tok_Error;
  63.     atom_s = atm;
  64.     dict = alloc_cons(atm, dict);
  65.     
  66.     atm = string_to_atom(aname_s2);
  67.     if (atm == tok_Error)
  68.         return tok_Error;
  69.     atom_s2 = atm;
  70.     dict = alloc_cons(atm, dict);
  71.     
  72.     atm = string_to_atom(aname_s3);
  73.     if (atm == tok_Error)
  74.         return tok_Error;
  75.     atom_s3 = atm;
  76.     dict = alloc_cons(atm, dict);
  77.     
  78.     if (dict == tok_Error)
  79.         return tok_Error;
  80.  
  81.     ! finished with dictionary. Now add it, and other stuff, to the top_level_env.
  82.     
  83.     atm = string_to_atom(aname_internal_dict);
  84.     if (atm == tok_Error)
  85.         return tok_Error;
  86.     ix = alloc_cons(atm, dict);
  87.     top_level_env = alloc_cons(ix, top_level_env);
  88.     if (top_level_env == tok_Error)
  89.         return tok_Error;
  90.     
  91.     if (build_function(bt_Form, aname_error, -1, #r$fn_error) == tok_Error)
  92.         return tok_Error;
  93.     
  94.     if (build_function(bt_Function, aname_plus, -1, #r$fn_plus) == tok_Error)
  95.         return tok_Error;
  96.     
  97.     if (build_function(bt_Function, aname_minus, -1, #r$fn_minus) == tok_Error)
  98.         return tok_Error;
  99.     
  100.     if (build_function(bt_Function, aname_gt, -1, #r$fn_gt) == tok_Error)
  101.         return tok_Error;
  102.     
  103.     if (build_function(bt_Function, aname_lt, -1, #r$fn_lt) == tok_Error)
  104.         return tok_Error;
  105.     
  106.     if (build_function(bt_Function, aname_gte, -1, #r$fn_gte) == tok_Error)
  107.         return tok_Error;
  108.     
  109.     if (build_function(bt_Function, aname_lte, -1, #r$fn_lte) == tok_Error)
  110.         return tok_Error;
  111.     
  112.     if (build_function(bt_Function, aname_eqnum, -1, #r$fn_eqnum) == tok_Error)
  113.         return tok_Error;
  114.     
  115.     if (build_function(bt_Function, aname_eqvp, 2, #r$fn_eqvp) == tok_Error)
  116.         return tok_Error;
  117.     
  118.     if (build_function(bt_Function, aname_equalp, 2, #r$fn_equalp) == tok_Error)
  119.         return tok_Error;
  120.     
  121.     if (build_function(bt_Function, aname_not, 1, #r$fn_not) == tok_Error)
  122.         return tok_Error;
  123.     
  124.     if (build_function(bt_Function, aname_nullp, 1, #r$fn_nullp) == tok_Error)
  125.         return tok_Error;
  126.     
  127.     if (build_function(bt_Function, aname_listp, 1, #r$fn_listp) == tok_Error)
  128.         return tok_Error;
  129.     
  130.     if (build_function(bt_Function, aname_list, -1, #r$fn_list) == tok_Error)
  131.         return tok_Error;
  132.     
  133.     if (build_function(bt_Function, aname_length, 1, #r$fn_length) == tok_Error)
  134.         return tok_Error;
  135.     
  136.     if (build_function(bt_Form, aname_cond, -1, #r$fn_cond) == tok_Error)
  137.         return tok_Error;
  138.     
  139.     if (build_function(bt_Function, aname_eval, 1, #r$fn_eval) == tok_Error)
  140.         return tok_Error;
  141.     
  142.     if (build_function(bt_Form, aname_define, 2, #r$fn_define) == tok_Error)
  143.         return tok_Error;
  144.     
  145.     if (build_function(bt_Form, aname_let, 2, #r$fn_let) == tok_Error)
  146.         return tok_Error;
  147.     
  148.     if (build_function(bt_Form, aname_letrec, 2, #r$fn_letrec) == tok_Error)
  149.         return tok_Error;
  150.     
  151.     if (build_function(bt_Form, aname_letstar, 2, #r$fn_letstar) == tok_Error)
  152.         return tok_Error;
  153.     
  154.     if (build_function(bt_Form, aname_lambda, 2, #r$fn_lambda) == tok_Error)
  155.         return tok_Error;
  156.     
  157.     if (build_function(bt_Function, aname_car, 1, #r$fn_car) == tok_Error)
  158.         return tok_Error;
  159.     
  160.     if (build_function(bt_Function, aname_cdr, 1, #r$fn_cdr) == tok_Error)
  161.         return tok_Error;
  162.     
  163.     if (build_function(bt_Function, aname_cons, 2, #r$fn_cons) == tok_Error)
  164.         return tok_Error;
  165.     
  166.     if (build_function(bt_Form, aname_quote, 1, #r$fn_quote) == tok_Error)
  167.         return tok_Error;
  168.     
  169.     atm = string_to_atom(aname_nil);
  170.     if (atm == tok_Error)
  171.         return tok_Error;
  172.     ix = alloc_cons(atm, 0);
  173.     top_level_env = alloc_cons(ix, top_level_env);
  174.     if (top_level_env == tok_Error)
  175.         return tok_Error;
  176.     
  177.     atm = string_to_atom(aname_t);
  178.     if (atm == tok_Error)
  179.         return tok_Error;
  180.     ix = alloc_cons(atm, atm);
  181.     top_level_env = alloc_cons(ix, top_level_env);
  182.     if (top_level_env == tok_Error)
  183.         return tok_Error;
  184.     atom_t = atm;
  185.     
  186.     return 0;
  187. ];
  188.  
  189. [ build_function funcform fname args fptr
  190.     atm ix val;
  191.     atm = string_to_atom(fname);
  192.     if (atm == tok_Error)
  193.         return tok_Error;
  194.     val = alloc_node(funcform, 0, 
  195.         alloc_node(bt_Builtin, num_to_atom(args), num_to_atom(fptr)));
  196.     if (val == tok_Error)
  197.         return tok_Error;
  198.     ix = alloc_cons(atm, val);
  199.     ix = alloc_cons(ix, top_level_env);
  200.     if (ix == tok_Error)
  201.         return tok_Error;
  202.     top_level_env = ix;
  203.     return 0;
  204. ];
  205.  
  206. ! --- the built-in functions and forms. Note that the supplied arguments
  207. !       will never be tok_Error, and there will be the right number of them.
  208.  
  209. [ fn_debug 
  210.     ix;
  211.     print "[debug got ", num_list_args, " args:^";
  212.     for (ix=0 : ix < num_list_args : ix++) {
  213.         print "  ", ix, ": ";
  214.         write_obj(list_args-->ix);
  215.         new_line;
  216.     }
  217.     print "]^";
  218.     return 0;
  219. ];
  220.  
  221. [ fn_quote;
  222.     return list_args-->0;
  223. ];
  224.  
  225. [ fn_list;
  226.     return list_args-->0;
  227. ];
  228.  
  229. [ fn_lambda env
  230.     v;
  231.     v = list_args-->0;
  232.     if (v ~= 0 && v->0 ~= bt_Cons && v->0 ~= bt_Atom) {
  233.         show_error("lambda: bad argument template", v, 1);
  234.         return tok_Error;
  235.     }
  236.     v = alloc_node(bt_Dynamic, v, list_args-->1);
  237.     if (v == tok_Error)
  238.         return tok_Error;
  239.     v = alloc_node(bt_Function, env, v);
  240.     if (v == tok_Error)
  241.         return tok_Error;
  242.     return v;
  243. ];
  244.  
  245. [ fn_define env
  246.     envp namat def s;
  247.     namat = list_args-->0;
  248.     def = list_args-->1;
  249.     if (namat == 0 || namat->0 ~= bt_Atom) {
  250.         show_error("define: first argument is not an atom", namat, 1);
  251.         return tok_Error;
  252.     }
  253.     def = eval_obj(def, env);
  254.     if (def == tok_Error)
  255.         return tok_Error;
  256.     envp = top_level_env;
  257.     for ( : envp ~= 0 : envp = envp-->2) {
  258.         s = envp-->1;
  259.         if ((s-->1)-->1 == namat-->1) {
  260.             break;
  261.         }
  262.     }
  263.     if (envp == 0) {
  264.         ! didn't find the atom; add it to top_level_env
  265.         s = alloc_cons(namat, def);
  266.         s = alloc_cons(s, top_level_env);
  267.         if (s == tok_Error)
  268.             return tok_Error;
  269.         top_level_env = s;
  270.     }
  271.     else {
  272.         ! found it; it's s.
  273.         s-->2 = def;
  274.     }
  275.     return def;
  276. ];
  277.  
  278. [ fn_eval env
  279.     s;
  280.     s = list_args-->0;
  281.     s = eval_obj(s, env);
  282.     return s;
  283. ];
  284.  
  285. [ fn_let env
  286.     defs expr s atm adef newenv;
  287.     defs = list_args-->0;
  288.     expr = list_args-->1;
  289.     if (defs ~= 0 && defs->0 ~= bt_Cons) {
  290.         show_error("let: first argument is not a list of lists", defs, 1);
  291.         return tok_Error;
  292.     }
  293.     newenv = env;
  294.     for ( : defs~=0 : defs=defs-->2 ) {
  295.         s = defs-->1;
  296.         if (s ~= 0 && s->0 ~= bt_Cons) {
  297.             show_error("let: binding is not a list", s, 1);
  298.             return tok_Error;
  299.         }
  300.         atm = s-->1;
  301.         if (atm == 0 || atm->0 ~= bt_Atom) {
  302.             show_error("let: binding must start with an atom", s, 1);
  303.             return tok_Error;
  304.         }
  305.         adef = s-->2;
  306.         if (adef == 0 || adef->0 ~= bt_Cons) {
  307.             show_error("let: binding must contain a definition", s, 1);
  308.             return tok_Error;
  309.         }
  310.         adef = adef-->1;
  311.         adef = eval_obj(adef, env);
  312.         if (adef == tok_Error)
  313.             return tok_Error;
  314.         newenv = alloc_cons(alloc_cons(atm, adef), newenv);
  315.         if (newenv == tok_Error)
  316.             return tok_Error;
  317.     }
  318.     s = eval_obj(expr, newenv);
  319.     return s;
  320. ];
  321.  
  322. [ fn_letrec env
  323.     origdefs defs expr s atm adef newenv tmpenv;
  324.     origdefs = list_args-->0;
  325.     expr = list_args-->1;
  326.     if (origdefs ~= 0 && origdefs->0 ~= bt_Cons) {
  327.         show_error("letrec: first argument is not a list of lists", origdefs, 1);
  328.         return tok_Error;
  329.     }
  330.     newenv = env;
  331.     for ( defs = origdefs : defs~=0 : defs=defs-->2 ) {
  332.         s = defs-->1;
  333.         if (s ~= 0 && s->0 ~= bt_Cons) {
  334.             show_error("letrec: binding is not a list", s, 1);
  335.             return tok_Error;
  336.         }
  337.         atm = s-->1;
  338.         if (atm == 0 || atm->0 ~= bt_Atom) {
  339.             show_error("letrec: binding must start with an atom", s, 1);
  340.             return tok_Error;
  341.         }
  342.         adef = 0;
  343.         newenv = alloc_cons(alloc_cons(atm, adef), newenv);
  344.         if (newenv == tok_Error)
  345.             return tok_Error;
  346.     }
  347.     tmpenv = newenv;
  348.     for ( defs = origdefs : defs~=0 : defs=defs-->2 ) {
  349.         s = defs-->1;
  350.         atm = s-->1;
  351.         adef = s-->2;
  352.         if (adef == 0 || adef->0 ~= bt_Cons) {
  353.             show_error("letrec: binding must contain a definition", s, 1);
  354.             return tok_Error;
  355.         }
  356.         adef = adef-->1;
  357.         adef = eval_obj(adef, newenv);
  358.         if (adef == tok_Error)
  359.             return tok_Error;
  360.         (tmpenv-->1)-->1 = atm;
  361.         (tmpenv-->1)-->2 = adef;
  362.         tmpenv = tmpenv-->2;
  363.     }
  364.     s = eval_obj(expr, newenv);
  365.     return s;
  366. ];
  367.  
  368. [ fn_letstar env
  369.     defs expr s atm adef;
  370.     defs = list_args-->0;
  371.     expr = list_args-->1;
  372.     if (defs ~= 0 && defs->0 ~= bt_Cons) {
  373.         show_error("let: first argument is not a list of lists", defs, 1);
  374.         return tok_Error;
  375.     }
  376.     for ( : defs~=0 : defs=defs-->2 ) {
  377.         s = defs-->1;
  378.         if (s ~= 0 && s->0 ~= bt_Cons) {
  379.             show_error("let: binding is not a list", s, 1);
  380.             return tok_Error;
  381.         }
  382.         atm = s-->1;
  383.         if (atm == 0 || atm->0 ~= bt_Atom) {
  384.             show_error("let: binding must start with an atom", s, 1);
  385.             return tok_Error;
  386.         }
  387.         adef = s-->2;
  388.         if (adef == 0 || adef->0 ~= bt_Cons) {
  389.             show_error("let: binding must contain a definition", s, 1);
  390.             return tok_Error;
  391.         }
  392.         adef = adef-->1;
  393.         adef = eval_obj(adef, env);
  394.         if (adef == tok_Error)
  395.             return tok_Error;
  396.         env = alloc_cons(alloc_cons(atm, adef), env);
  397.         if (env == tok_Error)
  398.             return tok_Error;
  399.     }
  400.     s = eval_obj(expr, env);
  401.     return s;
  402. ];
  403.  
  404. [ fn_length
  405.     s len;
  406.     len = 0;
  407.     for (s = list_args-->0 : s ~= 0 : s = s-->2, len++ ) {
  408.         if (s->0 ~= bt_Cons) {
  409.             show_error("length: not a proper list", list_args-->0, 1);
  410.             return tok_Error;
  411.         }
  412.     }
  413.     return num_to_atom(len);
  414. ];
  415.  
  416. [ fn_cons;
  417.     return alloc_cons(list_args-->0, list_args-->1);
  418. ];
  419.  
  420. [ fn_car
  421.     s;
  422.     s = list_args-->0;
  423.     if (s == 0 || s->0 ~= bt_Cons) {
  424.         show_error("car: bad argument", s, 1);
  425.         return tok_Error;
  426.     }
  427.     return (s-->1);
  428. ];
  429.  
  430. [ fn_cdr
  431.     s;
  432.     s = list_args-->0;
  433.     if (s == 0 || s->0 ~= bt_Cons) {
  434.         show_error("cdr: bad argument", s, 1);
  435.         return tok_Error;
  436.     }
  437.     return (s-->2);
  438. ];
  439.  
  440. [ fn_not
  441.     ;
  442.     if (is_true(list_args-->0) ~= 0)
  443.         return 0;
  444.     else
  445.         return atom_t;
  446. ];
  447.  
  448. [ fn_nullp
  449.     ;
  450.     if (list_args-->0 ~= 0)
  451.         return 0;
  452.     else
  453.         return atom_t;
  454. ];
  455.  
  456. [ fn_listp
  457.     s;
  458.     s = list_args-->0;
  459.     if (s == 0)
  460.         return atom_t;
  461.     if (s->0 == bt_Cons)
  462.         return atom_t;
  463.     return 0;
  464. ];
  465.  
  466. [ fn_cond env
  467.     s cl tex cle;
  468.     s = list_args-->0;
  469.     for ( : s ~= 0 : s = s-->2) {
  470.         if (s->0 ~= bt_Cons) {
  471.             show_error("cond: argument is not a list", s, 1);
  472.             return tok_Error;
  473.         }
  474.         cl = s-->1;
  475.         if (cl->0 ~= bt_Cons) {
  476.             show_error("cond: clause is not a list", cl, 1);
  477.             return tok_Error;
  478.         }
  479.         tex = cl-->1;
  480.         tex = eval_obj(tex, env);
  481.         if (tex == tok_Error)
  482.             return tok_Error;
  483.         if (is_true(tex) ~= 0) {
  484.             cle = cl-->2;
  485.             if (cle == 0) 
  486.                 return tex;
  487.             if (cle->0 ~= bt_Cons) {
  488.                 show_error("cond: clause does not end in an expression", cl, 1);
  489.                 return tok_Error;
  490.             }
  491.             tex = eval_obj(cle-->1, env);
  492.             return tex;
  493.         }
  494.     }
  495.     return 0;
  496. ];
  497.  
  498. [ fn_eqvp
  499.     s1 s2;
  500.     s1 = list_args-->0;
  501.     s2 = list_args-->1;
  502.     if (s1 == s2)
  503.         return atom_t;
  504.     if (s1 == 0 || s2 == 0)
  505.         return 0;
  506.     if (s1->0 ~= s2->0)
  507.         return 0;
  508.     switch (s1->0) {
  509.         bt_Atom, bt_Num:
  510.             if (s1-->1 == s2-->1)
  511.                 return atom_t;
  512.             return 0;
  513.         bt_Cons:
  514.             return 0;
  515.         default:
  516.             return 0;
  517.     }
  518. ];
  519.  
  520. [ fn_equalp
  521.     ;
  522.     return is_equalp(list_args-->0, list_args-->1);
  523. ];
  524.  
  525. [ is_equalp s1 s2;
  526.     if (s1 == s2)
  527.         return atom_t;
  528.     if (s1 == 0 || s2 == 0)
  529.         return 0;
  530.     if (s1->0 ~= s2->0)
  531.         return 0;
  532.     switch (s1->0) {
  533.         bt_Atom, bt_Num:
  534.             if (s1-->1 == s2-->1)
  535.                 return atom_t;
  536.             return 0;
  537.         bt_Cons:
  538.             if (is_equalp(s1-->1, s2-->1) == 0)
  539.                 return 0;
  540.             if (is_equalp(s1-->2, s2-->2) == 0)
  541.                 return 0;
  542.             return atom_t;
  543.         default:
  544.             return 0;
  545.     }
  546. ];
  547.  
  548. [ fn_gt;
  549.     return fn_numcompare(aname_gt);
  550. ];
  551.  
  552. [ fn_lt;
  553.     return fn_numcompare(aname_lt);
  554. ];
  555.  
  556. [ fn_gte;
  557.     return fn_numcompare(aname_gte);
  558. ];
  559.  
  560. [ fn_lte;
  561.     return fn_numcompare(aname_lte);
  562. ];
  563.  
  564. [ fn_eqnum;
  565.     return fn_numcompare(aname_eqnum);
  566. ];
  567.  
  568. [ fn_numcompare op
  569.     s v cur;
  570.     s = list_args-->0;
  571.     if (s == 0) {
  572.         show_error("numeric compare: must have at least one argument");
  573.         return tok_Error;
  574.     }
  575.     v = s-->1;
  576.     if (v == 0 || v->0 ~= bt_Num) {
  577.         show_error("numeric compare: non-numeric argument", v, 1);
  578.         return tok_Error;
  579.     }
  580.     cur = v-->1;
  581.     for ( s = s-->2 : s ~= 0 : s = s-->2 ) {
  582.         v = s-->1;
  583.         if (v == 0 || v->0 ~= bt_Num) {
  584.             show_error("numeric compare: non-numeric argument", v, 1);
  585.             return tok_Error;
  586.         }
  587.         switch (op) {
  588.             aname_gt:
  589.                 if (cur <= v-->1) return 0;
  590.             aname_lt:
  591.                 if (cur >= v-->1) return 0;
  592.             aname_gte:
  593.                 if (cur < v-->1) return 0;
  594.             aname_lte:
  595.                 if (cur > v-->1) return 0;
  596.             aname_eqnum:
  597.                 if (cur ~= v-->1) return 0;
  598.         }
  599.         cur = v-->1;
  600.     }
  601.     return atom_t;
  602. ];
  603.  
  604. [ fn_plus
  605.     sum ptr v;
  606.     sum = 0;
  607.     for ( ptr = list_args-->0 : ptr~=0 : ptr=ptr-->2 ) {
  608.         v = ptr-->1;
  609.         if (v == 0 || v->0 ~= bt_Num) {
  610.             show_error("+: non-numeric argument", v, 1);
  611.             return tok_Error;
  612.         }
  613.         sum = sum + v-->1;
  614.     }
  615.     return num_to_atom(sum);
  616. ];
  617.  
  618. [ fn_minus
  619.     sum ptr v pos;
  620.     sum = 0;
  621.     pos = 0;
  622.     for ( ptr = list_args-->0 : ptr~=0 : ptr=ptr-->2, pos++ ) {
  623.         v = ptr-->1;
  624.         if (v == 0 || v->0 ~= bt_Num) {
  625.             show_error("+: non-numeric argument", v, 1);
  626.             return tok_Error;
  627.         }
  628.         if (pos == 0) {
  629.             sum = sum + v-->1;
  630.         }
  631.         else {
  632.             sum = sum - v-->1;
  633.         }
  634.     }
  635.     if (pos == 1)
  636.         sum = 0-sum;
  637.     return num_to_atom(sum);
  638. ];
  639.  
  640. [ fn_error;
  641.     show_error();
  642.     return tok_Error;
  643. ];
  644.